home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / save-forth < prev    next >
Encoding:
Text File  |  1992-01-25  |  6.1 KB  |  217 lines
  1. ( Save an executable image on the Amiga disk -- 08-jul-86 )
  2.  
  3. ( The program must build several data areas <hunks> in a file... )
  4. ( 1. the header...name of program <optional>, hunk map, list of needed libs )
  5. ( 2. the code...the actual copy of the image from relative 0 to the filler )
  6. (    area past the top of the stack )
  7. ( 3. a zero-sized bss hunk <uninitialized data area...we have none > )
  8. ( 4. possibly a reloc32 hunk if we have references for the Amiga loader )
  9. (    to resolve. )
  10.  
  11. include jf:Long-References
  12. include jf:MakeIcon
  13.  
  14. hex
  15.  
  16. 3e9 constant hunk_code
  17. 3ea constant hunk_data
  18. 3ec constant hunk_reloc32
  19. 3f3 constant hunk_header
  20. 3f2 constant hunk_end
  21.  
  22. decimal
  23.  
  24. user #k           64 #k !
  25.  
  26. variable save-error
  27. : save,  ( cell -- , send to file unless error )
  28.   ferror @  save-error @ or
  29.   IF    drop  save-error on
  30.   ELSE  tempf,
  31.   THEN  ;
  32.  
  33. : write_hunk_header   ( #bytes-in-code -- , write the main file header )
  34. \  ." writing hunk_header..." cr
  35.   hunk_header save,       ( start of header hunk )
  36.   0           save,       ( no name given currently )
  37.   2  #relocs @
  38.   IF   1+
  39.   THEN        save,       ( number of hunks to load )
  40.   0           save,       ( no resident library names to load )
  41.   1  #relocs @
  42.   IF   1+  
  43.   THEN        save,       ( number of last hunk )
  44.   cell/       save,       ( #longwords in code hunk )
  45.   #relocs @
  46.   IF  relocs @ sizemem 3 + save,      ( #cells in reloc-32 table )
  47.   THEN
  48.   0           save,       ( zero-sized bss hunk )
  49. ;
  50.  
  51. ( NOTE:  before copying the user area to the file, the system should install )
  52. (        the new 'S0' as it is required to be valid at startup...rest of the )
  53. (        pertinant FORTH regs are initialized at startup. )
  54.  
  55. : write_hunk_code     ( image-size -- , write the code chunk of the image )
  56. \  ." writing hunk_code..."  cr
  57.   absrelocs @ >r  0 absrelocs !
  58.   0 relocs +boots !
  59.   hunk_code   save,       ( start of code hunk )
  60.   dup cell/ save,         ( #bytes-to-write  -- )
  61.   here  3 + -4 and     ( #-to-write  #-to-here  -- )
  62. \
  63. \ save-error @  0= 
  64. \ IF
  65. \    tempfile @  tempbuff  CloseFVWrite   ( #-to-write  #-to-here  -- )
  66. \    tempfile @  0  2 pick  fwrite  drop
  67. \    ferror @  save-error !
  68. \    tempbuff OpenFV  drop
  69. \ THEN 
  70. \
  71.   dup  0
  72.   DO    i @   save,  cell ( ...copy necessary code )
  73.   +LOOP
  74. \
  75.   relocs @ relocs +boots !
  76.   -   ( -- #-above-here )
  77.   #U @ cells dup >r -
  78.   0               ( #-above-here  0  -- )
  79.   DO    0     save,  cell ( ...fill area with zeros )
  80.  +LOOP  UP@ #U0 @
  81.   0
  82.   DO    dup @ save,  cell+
  83.   LOOP  drop r> cell/ #U0 @ -
  84.   0
  85.   DO    0     save,   ( ...fill area with zeros )
  86.   LOOP
  87.   r> absrelocs !
  88. ;
  89.  
  90. : write_hunk_empty  ( -- , why it does this ??? i won't even guess!!! )
  91. \  ." writing empty hunk_bss..." cr
  92.   hunk_code   save, 
  93.   0           save, 
  94.   hunk_end    save, 
  95. ;
  96.  
  97. : unrelocate  ( -- )
  98.   #relocs @
  99.   IF   \ ." unrelocating..." cr
  100.        RelocsAdr #relocs @  ( adr #relocs -- )  0
  101.        DO  dup @  ( relocblk relocaddr1 -- )
  102.            dup @  ( rblk raddr1 absaddr -- )  0 >abs -  swap !  cell+
  103.        LOOP  drop
  104.   THEN
  105. ;
  106.  
  107. : relocate  ( -- )
  108.   #relocs @
  109.   IF   \ ." relocating..." cr
  110.        relocs @ #relocs @   ( adr #relocs -- )  0
  111.        DO  dup @  ( relocblk relocaddr1 -- )
  112.            dup @  ( rblk raddr1 reladdr -- )  0 >abs +  swap !  cell+
  113.        LOOP  drop
  114.   THEN
  115. ;
  116.  
  117. : write_hunk_reloc32  ( -- )
  118.   #relocs @
  119.   IF   \ ." writing hunk_reloc32..." cr
  120.  
  121.        hunk_reloc32   save, 
  122.        Relocs @ #relocs @  ( adr #relocs -- )  dup save, 
  123.        0 save,    ( hunk# to link with )   0
  124.        DO  dup @  ( relocblk relocaddr1 -- )  save,   cell+
  125.        LOOP drop
  126.        ( now for the relocs_hunk to be relocated at ABSRelocs )
  127.        1 save,    ( #relocs )
  128.        1 save,    ( hunk# )
  129.        ABSRelocs up@ up0 @ -  -  save,   ( address to put reloc addr )
  130.        0 save,    ( no more relocs )
  131.   THEN
  132. ;
  133.  
  134. : write_relocs_data  ( -- , write relocs as relocatable data hunk )
  135.   #relocs @
  136.   IF   \  ." writing hunk_data, forth relocation map..." cr
  137.         hunk_data   save, 
  138.         relocs @ 3 cells -   ( addr of start of area )
  139.         relocs @ sizemem cell/
  140.         3 + dup save,   0
  141.         DO   dup @ save,    cell+
  142.         LOOP drop
  143.         hunk_end save, 
  144.   THEN
  145. ;
  146.  
  147. : SetBootArea  ( #bytes-in-image -- )
  148.   #U @ cells -  dup UP0 !    32 -
  149.   dup [ s0      up@ - userboots + ] literal !   ( set new stack value )
  150.       [ dplimit up@ - userboots + ] literal !   ( set new dplimit value )
  151.   \ 0  fcloseatbye +boots !   \ system must not think these exist at startup
  152.   \ 0  freeatbye   +boots !
  153.   \ 0  fcloselist  +boots !
  154.   \ 0  freeuplist  +boots !
  155.   \ any new inits go here...
  156. ;
  157.  
  158. : RestoreBootArea ( -- )
  159.   s0 @ 32 +  up0 !    #U0 @ #U !
  160.   s0 @ dup  [ s0      up@ - userboots + ] literal !
  161.             [ dplimit up@ - userboots + ] literal !
  162.   freeze  \ user area should be good!
  163. ;
  164.  
  165. : write_image_file  ( create a file im my image ... no error checking yet )
  166.   #k @ 1024 *         ( #bytes-desired -- )
  167.   here 1024 +   1024 /mod swap
  168.   IF   1+
  169.   THEN   1024 *  >r
  170.   #U @ cells  >r
  171.   r@ +   r> r> +
  172.        ( #bytes-desired  #bytes-needed-min  -- )
  173.   max  ( #bytes-to-write -- )
  174.   dup SetBootArea 
  175.   dup write_hunk_header
  176.   unrelocate          ( all abs 32 bit addresses -> relative )
  177.   write_hunk_code
  178.   relocate            ( put them back to absolute )
  179.   write_hunk_reloc32
  180.   hunk_end    save, 
  181.   write_relocs_data
  182.   write_hunk_empty
  183.   RestoreBootArea
  184. ;
  185.  
  186. : .image  ( -- )
  187.        ?forgotten
  188.        >newline    ." This image is "  #relocs @ -dup
  189.        IF    ." relocatable, " . ." long references."
  190.        ELSE  ." position-independant."
  191.        THEN  cr
  192. ;
  193.  
  194. : (save-forth)  ( file-pointer -- )
  195.   >newline  cr ?forgotten  ( clean up the reloc-32 table, if one is there )
  196.   freeze  tempfile !
  197.   .image cr  ferror off save-error off
  198.   ." Writing executable file: "  dosstring 1+ count type cr cr
  199.   tempbuff OpenFV  drop
  200.   write_image_file
  201.   save-error @
  202.   IF    ." Error writing file." cr
  203.   ELSE  MakeIcon
  204.   THEN  tempfile @  tempbuff closeFVWrite
  205.   tempfile @  fclose  ;
  206.  
  207. variable save-forth-to
  208.  
  209. : SAVE-FORTH  ( -- , <name> create bootable image of present state )
  210.   save-forth-to @ -dup 0=
  211.   IF   new fopen
  212.   THEN save-forth-to off   -dup
  213.   IF   (save-forth)
  214.   ELSE cr ." can't open "  dosstring 1+ count type ."  for writing!"  quit
  215.   THEN
  216. ;
  217.